home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / interp / instance.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  53.4 KB  |  1,960 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: instance.c,v 1.34 94/12/10 00:21:55 nkramer Exp $
  27. *
  28. * This file implements instances and user defined classes.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include "../compat/std-c.h"
  33.  
  34. #include "mindy.h"
  35. #include "gc.h"
  36. #include "obj.h"
  37. #include "class.h"
  38. #include "list.h"
  39. #include "vec.h"
  40. #include "type.h"
  41. #include "bool.h"
  42. #include "module.h"
  43. #include "num.h"
  44. #include "thread.h"
  45. #include "func.h"
  46. #include "sym.h"
  47. #include "value.h"
  48. #include "error.h"
  49. #include "driver.h"
  50. #include "def.h"
  51. #include "print.h"
  52. #include "instance.h"
  53.  
  54. struct slot_descr {
  55.     obj_t class;
  56.     obj_t name;
  57.     enum slot_allocation alloc;
  58.     obj_t creator;
  59.     obj_t init_function_or_value;
  60.     boolean init_function_p;
  61.     obj_t init_keyword;
  62.     boolean keyword_required;
  63.     obj_t getter;
  64.     obj_t getter_method;
  65.     obj_t setter;
  66.     obj_t setter_method;
  67.     obj_t type;
  68.     int desired_offset;
  69.     boolean ever_missed;
  70. };
  71.  
  72. #define SD(o) obj_ptr(struct slot_descr *, o)
  73.  
  74. struct initarg_descr {
  75.     obj_t class;
  76.     obj_t keyword;
  77.     boolean required_p;
  78.     obj_t type;
  79.     obj_t init_function_or_value;
  80.     boolean init_function_p;
  81.     obj_t initializer;
  82. };
  83.  
  84. #define INTD(o) obj_ptr(struct initarg_descr *, o)
  85.  
  86. struct inherited_descr {
  87.     obj_t class;
  88.     obj_t name;
  89.     obj_t init_function_or_value;
  90.     boolean init_function_p;
  91. };
  92.  
  93. #define INHD(o) obj_ptr(struct inherited_descr *, o)
  94.  
  95. struct postable {
  96.     obj_t class;
  97.     obj_t alist;
  98. };
  99.  
  100. #define PT(o) obj_ptr(struct postable *, o)
  101.  
  102. enum initializer_kind { slot_Initializer, initarg_slot_Initializer,
  103.             initarg_Initializer, inherited_Initializer };
  104.  
  105. struct initializer {
  106.     obj_t class;
  107.     enum initializer_kind kind;
  108.     obj_t slot;
  109.     obj_t initarg;
  110.     obj_t inherited;
  111. };
  112.  
  113. #define INITIALIZER(o) obj_ptr(struct initializer *, o)
  114.  
  115. struct instance {
  116.     obj_t class;
  117.     obj_t slots[1];
  118. };
  119.  
  120. #define INST(o) obj_ptr(struct instance *, o)
  121.  
  122. obj_t obj_DefinedClassClass = NULL;
  123. static obj_t obj_SlotDescrClass = NULL;
  124. static obj_t obj_InitargDescrClass = NULL;
  125. static obj_t obj_InheritedDescrClass = NULL;
  126. static obj_t obj_PosTableClass = NULL;
  127. static obj_t obj_InitializerClass = NULL;
  128.  
  129.  
  130. /* Accessor methods. */
  131.  
  132. static int find_position(obj_t pt, obj_t slot);
  133.  
  134. static void slow_instance_getter(obj_t method, struct thread *thread,
  135.                  obj_t *args)
  136. {
  137.     obj_t datum = accessor_method_datum(method);
  138.     obj_t *old_sp = args-1;
  139.     obj_t instance = args[0];
  140.     obj_t class = INST(instance)->class;
  141.     int index = find_position(DC(class)->instance_positions, datum);
  142.     obj_t value = INST(instance)->slots[index];
  143.  
  144.     if (value == obj_Unbound) {
  145.     push_linkage(thread, args);
  146.     error("Unbound slot.");
  147.     }
  148.  
  149.     *old_sp = value;
  150.     thread->sp = args;
  151.     do_return(thread, old_sp, old_sp);
  152. }
  153.  
  154. static void fast_instance_getter(obj_t method, struct thread *thread,
  155.                  obj_t *args)
  156. {
  157.     obj_t datum = accessor_method_datum(method);
  158.     obj_t *old_sp = args-1;
  159.     obj_t instance = args[0];
  160.     obj_t value = INST(instance)->slots[fixnum_value(datum)];
  161.  
  162.     if (value == obj_Unbound) {
  163.     push_linkage(thread, args);
  164.     error("Unbound slot.");
  165.     }
  166.  
  167.     *old_sp = value;
  168.     thread->sp = args;
  169.     do_return(thread, old_sp, old_sp);
  170. }
  171.  
  172. static void slow_instance_setter(obj_t method, struct thread *thread,
  173.                  obj_t *args)
  174. {
  175.     obj_t datum = accessor_method_datum(method);
  176.     obj_t *old_sp = args-1;
  177.     obj_t value = args[0];
  178.     obj_t instance = args[1];
  179.     obj_t class = INST(instance)->class;
  180.     int index = find_position(DC(class)->instance_positions, datum);
  181.  
  182.     INST(instance)->slots[index] = value;
  183.  
  184.     *old_sp = value;
  185.     thread->sp = args;
  186.     do_return(thread, old_sp, old_sp);
  187. }
  188.  
  189. static void fast_instance_setter(obj_t method, struct thread *thread,
  190.                  obj_t *args)
  191. {
  192.     obj_t datum = accessor_method_datum(method);
  193.     obj_t *old_sp = args-1;
  194.     obj_t value = args[0];
  195.     obj_t instance = args[1];
  196.  
  197.     INST(instance)->slots[fixnum_value(datum)] = value;
  198.  
  199.     *old_sp = value;
  200.     thread->sp = args;
  201.     do_return(thread, old_sp, old_sp);
  202. }
  203.  
  204. static void slow_subclass_getter(obj_t method, struct thread *thread,
  205.                  obj_t *args)
  206. {
  207.     obj_t datum = accessor_method_datum(method);
  208.     obj_t *old_sp = args-1;
  209.     obj_t instance = args[0];
  210.     obj_t class = INST(instance)->class;
  211.     int index = find_position(DC(class)->subclass_positions, datum);
  212.     obj_t value = SOVEC(DC(class)->subclass_slots)->contents[index];
  213.  
  214.     if (value == obj_Unbound) {
  215.     push_linkage(thread, args);
  216.     error("Unbound slot.");
  217.     }
  218.  
  219.     *old_sp = value;
  220.     thread->sp = args;
  221.     do_return(thread, old_sp, old_sp);
  222. }
  223.  
  224. static void fast_subclass_getter(obj_t method, struct thread *thread,
  225.                  obj_t *args)
  226. {
  227.     obj_t datum = accessor_method_datum(method);
  228.     obj_t *old_sp = args-1;
  229.     obj_t instance = args[0];
  230.     obj_t class = INST(instance)->class;
  231.     int index = fixnum_value(datum);
  232.     obj_t value = SOVEC(DC(class)->subclass_slots)->contents[index];
  233.  
  234.     if (value == obj_Unbound) {
  235.     push_linkage(thread, args);
  236.     error("Unbound slot.");
  237.     }
  238.  
  239.     *old_sp = value;
  240.     thread->sp = args;
  241.     do_return(thread, old_sp, old_sp);
  242. }
  243.  
  244. static void slow_subclass_setter(obj_t method, struct thread *thread,
  245.                  obj_t *args)
  246. {
  247.     obj_t datum = accessor_method_datum(method);
  248.     obj_t *old_sp = args-1;
  249.     obj_t value = args[0];
  250.     obj_t instance = args[1];
  251.     obj_t class = INST(instance)->class;
  252.     int index = find_position(DC(class)->subclass_positions, datum);
  253.  
  254.     SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  255.  
  256.     *old_sp = value;
  257.     thread->sp = args;
  258.     do_return(thread, old_sp, old_sp);
  259. }
  260.  
  261. static void fast_subclass_setter(obj_t method, struct thread *thread,
  262.                  obj_t *args)
  263. {
  264.     obj_t datum = accessor_method_datum(method);
  265.     obj_t *old_sp = args-1;
  266.     obj_t value = args[0];
  267.     obj_t instance = args[1];
  268.     obj_t class = INST(instance)->class;
  269.     int index = fixnum_value(datum);
  270.  
  271.     SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  272.  
  273.     *old_sp = value;
  274.     thread->sp = args;
  275.     do_return(thread, old_sp, old_sp);
  276. }
  277.  
  278. static void class_getter(obj_t method, struct thread *thread, obj_t *args)
  279. {
  280.     obj_t datum = accessor_method_datum(method);
  281.     obj_t *old_sp = args-1;
  282.     obj_t value = value_cell_ref(datum);
  283.  
  284.     if (value == obj_Unbound) {
  285.     push_linkage(thread, args);
  286.     error("Unbound slot.");
  287.     }
  288.  
  289.     *old_sp = value;
  290.     thread->sp = args;
  291.     do_return(thread, old_sp, old_sp);
  292. }
  293.  
  294. static void class_setter(obj_t method, struct thread *thread, obj_t *args)
  295. {
  296.     obj_t datum = accessor_method_datum(method);
  297.     obj_t *old_sp = args-1;
  298.     obj_t value = args[0];
  299.  
  300.     value_cell_set(datum, value);
  301.  
  302.     *old_sp = value;
  303.     thread->sp = args;
  304.     do_return(thread, old_sp, old_sp);
  305. }
  306.  
  307. static void constant_getter(obj_t method, struct thread *thread, obj_t *args)
  308. {
  309.     obj_t value = accessor_method_datum(method);
  310.     obj_t *old_sp = args-1;
  311.  
  312.     *old_sp = value;
  313.     thread->sp = args;
  314.     do_return(thread, old_sp, old_sp);
  315. }
  316.  
  317.  
  318.  
  319. /* Position tables. */
  320.  
  321. static obj_t make_position_table(void)
  322. {
  323.     obj_t res = alloc(obj_PosTableClass, sizeof(struct postable));
  324.  
  325.     PT(res)->alist = obj_Nil;
  326.  
  327.     return res;
  328. }
  329.  
  330. static void note_position(obj_t table, obj_t slot, int index)
  331. {
  332.     PT(table)->alist = pair(pair(slot, make_fixnum(index)), PT(table)->alist);
  333.  
  334.     if (!SD(slot)->ever_missed) {
  335.     SD(slot)->ever_missed = TRUE;
  336.     switch (SD(slot)->alloc) {
  337.       case alloc_INSTANCE:
  338.         set_method_iep(SD(slot)->getter_method, slow_instance_getter);
  339.         set_accessor_method_datum(SD(slot)->getter_method, slot);
  340.         if (SD(slot)->setter_method != obj_False) {
  341.         set_method_iep(SD(slot)->setter_method, slow_instance_setter);
  342.         set_accessor_method_datum(SD(slot)->setter_method, slot);
  343.         }
  344.         break;
  345.  
  346.       case alloc_SUBCLASS:
  347.         set_method_iep(SD(slot)->getter_method, slow_subclass_getter);
  348.         set_accessor_method_datum(SD(slot)->getter_method, slot);
  349.         if (SD(slot)->setter_method != obj_False) {
  350.         set_method_iep(SD(slot)->setter_method, slow_subclass_setter);
  351.         set_accessor_method_datum(SD(slot)->setter_method, slot);
  352.         }
  353.         break;
  354.  
  355.       default:
  356.         lose("Displacing a slot with allocation other than "
  357.          "instance or subclass?");
  358.         break;
  359.     }
  360.     }
  361. }
  362.  
  363. static int find_position(obj_t pt, obj_t slot)
  364. {
  365.     obj_t scan;
  366.  
  367.     if (pt != obj_False) {
  368.     for (scan = PT(pt)->alist; scan != obj_Nil; scan = TAIL(scan)) {
  369.         obj_t entry = HEAD(scan);
  370.  
  371.         if (HEAD(entry) == slot)
  372.         return fixnum_value(TAIL(entry));
  373.     }
  374.     }
  375.     return SD(slot)->desired_offset;
  376. }
  377.  
  378.  
  379. /* Slot descriptors. */
  380.  
  381. static obj_t make_slot_descriptor(obj_t name, obj_t allocation,
  382.                   obj_t getter, obj_t setter, obj_t type,
  383.                   obj_t init_keyword, obj_t req_init_keyword,
  384.                   obj_t init_function, obj_t init_value)
  385. {
  386.     obj_t res = alloc(obj_SlotDescrClass, sizeof(struct slot_descr));
  387.     enum slot_allocation alloc
  388.     = (enum slot_allocation)fixnum_value(allocation);
  389.  
  390.     SD(res)->name = name;
  391.     SD(res)->alloc = alloc;
  392.     SD(res)->creator = obj_False;
  393.     if (alloc == alloc_CONSTANT) {
  394.     if (init_value == obj_Unbound)
  395.         error("CONSTANT slots must have an init-value:");
  396.     if (req_init_keyword != obj_False)
  397.         error("Can't use required-init-keyword: in constant slots.");
  398.     if (init_keyword != obj_False)
  399.         error("Can't use init-keyword: in constant slots.");
  400.     }
  401.     if (init_function != obj_Unbound) {
  402.     if (init_value != obj_Unbound)
  403.         error("Can't specify both an init-function: and an init-value:");
  404.     SD(res)->init_function_or_value = init_function;
  405.     SD(res)->init_function_p = TRUE;
  406.     }
  407.     else {
  408.     if (init_value != obj_Unbound && type != obj_False)
  409.         check_type(init_value, type);
  410.     SD(res)->init_function_or_value = init_value;
  411.     SD(res)->init_function_p = FALSE;
  412.     }
  413.     if (req_init_keyword != obj_False) {
  414.     if (init_function != obj_Unbound)
  415.         error("Can't mix required-init-keyword: and init-function:");
  416.     if (init_value != obj_Unbound)
  417.         error("Can't mix required-init-keyword: and init-value:");
  418.     if (init_keyword != obj_False)
  419.         error("Can't mix required-init-keyword: and init-keyword:");
  420.     SD(res)->init_keyword = req_init_keyword;
  421.     SD(res)->keyword_required = TRUE;
  422.     }
  423.     else {
  424.     SD(res)->init_keyword = init_keyword;
  425.     SD(res)->keyword_required = FALSE;
  426.     }
  427.     SD(res)->getter = getter;
  428.     SD(res)->getter_method = obj_False;
  429.     SD(res)->setter = setter;
  430.     SD(res)->setter_method = obj_False;
  431.     if (type == obj_False)
  432.     SD(res)->type = obj_ObjectClass;
  433.     else
  434.     SD(res)->type = type;
  435.     SD(res)->desired_offset = -1;
  436.     SD(res)->ever_missed = FALSE;
  437.  
  438.     return res;
  439. }
  440.  
  441. /* Initarg Descriptors */
  442.  
  443. static obj_t make_initarg_descr(obj_t keyword, obj_t required, obj_t type,
  444.                 obj_t init_function, obj_t init_value)
  445. {
  446.     obj_t res = alloc(obj_InitargDescrClass, sizeof(struct initarg_descr));
  447.  
  448.     INTD(res)->keyword = keyword;
  449.     if (required != obj_False) {
  450.     if (init_function != obj_Unbound || init_value != obj_Unbound)
  451.         error("Can't specify initial value for required init arg.");
  452.     INTD(res)->required_p = TRUE;
  453.     }
  454.     else {
  455.         INTD(res)->required_p = FALSE;
  456.     }
  457.     if (type == obj_False) {
  458.         INTD(res)->type = obj_ObjectClass;
  459.     }
  460.     else {
  461.         INTD(res)->type = type;
  462.     }
  463.     if (init_function != obj_Unbound) {
  464.     if (init_value != obj_Unbound)
  465.         error("Can't specify both an init-function: and an init-value:");
  466.     INTD(res)->init_function_or_value = init_function;
  467.     INTD(res)->init_function_p = TRUE;
  468.     }
  469.     else {
  470.     INTD(res)->init_function_or_value = init_value;
  471.     INTD(res)->init_function_p = FALSE;
  472.     }
  473.     INTD(res)->initializer = obj_False;
  474.  
  475.     return res;
  476. }
  477.  
  478. /* Inherited Descriptors */
  479.  
  480. static obj_t make_inherited_descr(obj_t name,
  481.                   obj_t init_function, obj_t init_value)
  482. {
  483.     obj_t res = alloc(obj_InheritedDescrClass, sizeof(struct inherited_descr));
  484.  
  485.     INHD(res)->name = name;
  486.     if (init_function != obj_Unbound) {
  487.     if (init_value != obj_Unbound)
  488.         error("Can't specify both an init-function: and an init-value:");
  489.     INHD(res)->init_function_or_value = init_function;
  490.     INHD(res)->init_function_p = TRUE;
  491.     }
  492.     else {
  493.     INHD(res)->init_function_or_value = init_value;
  494.     INHD(res)->init_function_p = FALSE;
  495.     }
  496.  
  497.     return res;
  498. }
  499.  
  500.  
  501. /* Initializers */
  502.  
  503. static struct variable *initialize_gf_variable = NULL;
  504.  
  505. static obj_t make_initializer(enum initializer_kind kind, obj_t slot,
  506.                   obj_t initarg, obj_t inherited)
  507. {
  508.     obj_t res = alloc(obj_InitializerClass, sizeof(struct initializer));
  509.  
  510.     INITIALIZER(res)->kind = kind;
  511.     INITIALIZER(res)->slot = slot;
  512.     INITIALIZER(res)->initarg = initarg;
  513.     INITIALIZER(res)->inherited = inherited;
  514.  
  515.     return res;
  516. }
  517.  
  518. static obj_t slot_initializer(obj_t slot)
  519. {
  520.     return make_initializer(slot_Initializer, slot,
  521.                 obj_False, obj_False);
  522. }
  523.  
  524. static obj_t initarg_slot_initializer(obj_t slot, obj_t initarg)
  525. {
  526.     return make_initializer(initarg_slot_Initializer, slot,
  527.                 initarg, obj_False);
  528. }
  529.  
  530. static obj_t initarg_initializer(obj_t initarg)
  531. {
  532.     return make_initializer(initarg_Initializer, obj_False,
  533.                 initarg, obj_False);
  534. }
  535.  
  536. static obj_t inherited_initializer(obj_t slot, obj_t inherited)
  537. {
  538.     return make_initializer(inherited_Initializer, slot,
  539.                 obj_False, inherited);
  540. }
  541.  
  542. static boolean initializer_init_function_p(obj_t initializer)
  543. {
  544.     switch (INITIALIZER(initializer)->kind) {
  545.       case slot_Initializer:
  546.     return SD(INITIALIZER(initializer)->slot)->init_function_p;
  547.     break;
  548.       case initarg_slot_Initializer:
  549.     return INTD(INITIALIZER(initializer)->initarg)->init_function_p;
  550.     break;
  551.       case initarg_Initializer:
  552.     return INTD(INITIALIZER(initializer)->initarg)->init_function_p;
  553.     break;
  554.       case inherited_Initializer:
  555.     return INHD(INITIALIZER(initializer)->inherited)->init_function_p;
  556.     break;
  557.       default:
  558.     lose("Tried to get init_function_p from strange initializer.");
  559.     return FALSE;
  560.     }
  561. }
  562.  
  563. static obj_t initializer_init_function_or_value(obj_t initializer)
  564. {
  565.     switch (INITIALIZER(initializer)->kind) {
  566.       case slot_Initializer:
  567.     return SD(INITIALIZER(initializer)->slot)->init_function_or_value;
  568.     break;
  569.       case initarg_slot_Initializer:
  570.     return INTD(INITIALIZER(initializer)->initarg)->init_function_or_value;
  571.     break;
  572.       case initarg_Initializer:
  573.     return INTD(INITIALIZER(initializer)->initarg)->init_function_or_value;
  574.     break;
  575.       case inherited_Initializer:
  576.     return INHD(INITIALIZER(initializer)->inherited)->init_function_or_value;
  577.     break;
  578.       default:
  579.     lose("Tried to get init_function_or_value from strange initializer.");
  580.     return NULL;
  581.     }
  582. }
  583.  
  584. static void do_finish_initialization(struct thread *thread, obj_t *vals)
  585. {
  586.     obj_t inst_or_class = vals[-3];
  587.     obj_t *old_sp = pop_linkage(thread);
  588.  
  589.     *old_sp = inst_or_class;
  590.     thread->sp = old_sp + 1;
  591.  
  592.     do_return(thread, old_sp, old_sp);
  593. }
  594.  
  595. static void do_init_value(struct thread *thread, obj_t *vals);
  596.  
  597. static void do_initializers(struct thread *thread, obj_t initializers)
  598. {
  599.     obj_t *sp = thread->sp;
  600.  
  601.     /* If there are initializers left, get the init-value or call the
  602.        init-function, and give the value to do_init_value.
  603.  
  604.        If there are no initializers left, call the Dylan initialize
  605.        function with the defaulted initargs. */
  606.  
  607.     if (initializers != obj_Nil) {
  608.     obj_t initializer = HEAD(initializers);
  609.  
  610.     sp[-1] = initializers;
  611.     sp[0] = initializer_init_function_or_value(initializer);
  612.     thread->sp = sp + 1;
  613.     if (initializer_init_function_p(initializer)) {
  614.         set_c_continuation(thread, do_init_value);
  615.         invoke(thread, 0);
  616.     }
  617.     else {
  618.         do_init_value(thread, sp);
  619.     }
  620.     }
  621.     else {
  622.     obj_t inst_or_class = sp[-3];
  623.     obj_t initargs = sp[-2];
  624.     int nargs;
  625.  
  626.     *sp++ = initialize_gf_variable->value;
  627.     *sp++ = inst_or_class;
  628.     for ( ; initargs != obj_Nil; initargs = TAIL(initargs)) {
  629.         obj_t initarg = HEAD(initargs);
  630.         *sp++ = INTD(initarg)->keyword;
  631.         *sp++ = INTD(initarg)->init_function_or_value;
  632.     }
  633.     nargs = sp - thread->sp - 1;
  634.     thread->sp = sp;
  635.  
  636.     set_c_continuation(thread, do_finish_initialization);
  637.     invoke(thread, nargs);
  638.     }
  639. }
  640.  
  641. static void do_init_value(struct thread *thread, obj_t *vals)
  642. {
  643.     obj_t inst_or_class = vals[-3];
  644.     obj_t initializers = vals[-1];
  645.     obj_t initializer = HEAD(initializers);
  646.     obj_t value;
  647.     obj_t slot;
  648.     int index;
  649.     obj_t initarg;
  650.  
  651.     if (thread->sp == vals)
  652.     value = obj_False;
  653.     else {
  654.     value = vals[0];
  655.     thread->sp = vals;
  656.     }
  657.  
  658.     /* Initialize a slot if necessary */
  659.  
  660.     if (obj_ptr(struct object *, inst_or_class)->class
  661.       == obj_DefinedClassClass) {
  662.     obj_t class = inst_or_class;
  663.  
  664.     switch (INITIALIZER(initializer)->kind) {
  665.       case slot_Initializer:
  666.       case initarg_slot_Initializer:
  667.       case inherited_Initializer:
  668.         slot = INITIALIZER(initializer)->slot;
  669.         if (value != obj_Unbound && !instancep(value, SD(slot)->type))
  670.         type_error(value, SD(slot)->type);
  671.         switch (SD(slot)->alloc) {
  672.           case alloc_SUBCLASS:
  673.         index = find_position(DC(class)->subclass_positions, slot);
  674.         SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  675.         break;
  676.           case alloc_CLASS:
  677.         value_cell_set(accessor_method_datum(SD(slot)->getter_method),
  678.                    value);
  679.         break;
  680.           default:
  681.         lose("Tried to initialize a strange kind of class slot.");
  682.         }
  683.         break;
  684.       case initarg_Initializer:
  685.         break;
  686.       default:
  687.         lose("Strange kind of initializer.");
  688.     }
  689.     }
  690.     else {
  691.     obj_t instance = inst_or_class;
  692.     obj_t class = INST(instance)->class;
  693.  
  694.     switch (INITIALIZER(initializer)->kind) {
  695.       case slot_Initializer:
  696.       case initarg_slot_Initializer:
  697.       case inherited_Initializer:
  698.         slot = INITIALIZER(initializer)->slot;
  699.         if (value != obj_Unbound && !instancep(value, SD(slot)->type))
  700.             type_error(value, SD(slot)->type);
  701.         switch (SD(slot)->alloc) {
  702.           case alloc_INSTANCE:
  703.         index = find_position(DC(class)->instance_positions, slot);
  704.         INST(instance)->slots[index] = value;
  705.         break;
  706.           case alloc_SUBCLASS:
  707.         index = find_position(DC(class)->subclass_positions, slot);
  708.         SOVEC(DC(class)->subclass_slots)->contents[index] = value;
  709.         break;
  710.           case alloc_CLASS:
  711.         value_cell_set(accessor_method_datum(SD(slot)->getter_method),
  712.                    value);
  713.         break;
  714.           case alloc_VIRTUAL:
  715.         /* Do nothing with the value. */
  716.         break;
  717.           default:
  718.         lose("Tried to initialize a strange kind of instance slot.");
  719.         }
  720.         break;
  721.       case initarg_Initializer:
  722.         break;
  723.       default:
  724.         lose("Strange kind of initializer.");
  725.     }
  726.     }
  727.  
  728.     /* Initialize an initarg if necessary */
  729.  
  730.     switch (INITIALIZER(initializer)->kind) {
  731.       case initarg_slot_Initializer:
  732.       case initarg_Initializer:
  733.     initarg = INITIALIZER(initializer)->initarg;
  734.     if (value != obj_Unbound && !instancep(value, INTD(initarg)->type))
  735.         type_error(value, INTD(initarg)->type);
  736.     INTD(initarg)->init_function_or_value = value;
  737.     INTD(initarg)->init_function_p = FALSE;
  738.     break;
  739.       case slot_Initializer:
  740.       case inherited_Initializer:
  741.     break;
  742.       default:
  743.     lose("Strange kind of initializer.");
  744.     }
  745.  
  746.     do_initializers(thread, TAIL(initializers));
  747. }
  748.  
  749. static void do_initialization(obj_t inst_or_class, obj_t initargs,
  750.                   obj_t initializers)
  751. {
  752.     struct thread *thread = thread_current();
  753.     obj_t *sp = thread->sp += 3;
  754.  
  755.     sp[-3] = inst_or_class;
  756.     sp[-2] = initargs;
  757.     do_initializers(thread, initializers);
  758.     go_on();
  759. }
  760.  
  761.  
  762. /* Defined Classes */
  763.  
  764. static int scav_instance(struct object *ptr);
  765. static obj_t trans_instance(obj_t instance);
  766.  
  767. obj_t make_defined_class(obj_t debug_name, struct library *library)
  768. {
  769.     obj_t res = alloc(obj_DefinedClassClass, sizeof(struct defined_class));
  770.  
  771.     init_class_type_stuff(res);
  772.     DC(res)->abstract_p = FALSE;
  773.     DC(res)->sealed_p = FALSE;
  774.     DC(res)->library = library;
  775.     DC(res)->scavenge = scav_instance;
  776.     DC(res)->transport = trans_instance;
  777.     DC(res)->print = NULL;
  778.     DC(res)->debug_name = debug_name;
  779.     DC(res)->superclasses = obj_False;
  780.     DC(res)->cpl = obj_False;
  781.     DC(res)->direct_subclasses = obj_Nil;
  782.     DC(res)->all_subclasses = obj_Nil;
  783.     DC(res)->new_slots = obj_False;
  784.     DC(res)->all_slots = obj_False;
  785.     DC(res)->new_initargs = obj_False;
  786.     DC(res)->all_initargs = obj_False;
  787.     DC(res)->inheriteds = obj_False;
  788.     DC(res)->instance_positions = obj_False;
  789.     DC(res)->instance_length = 0;
  790.     DC(res)->instance_layout = obj_False;
  791.     DC(res)->subclass_positions = obj_False;
  792.     DC(res)->subclass_slots = obj_False;
  793.     DC(res)->subclass_layout = obj_False;
  794.  
  795.     return res;
  796. }
  797.  
  798. static void compute_lengths(obj_t class)
  799. {
  800.     obj_t scan, slots, layout;
  801.     int instance_length = 0;
  802.     int subclass_length = 0;
  803.     int i;
  804.  
  805.     for (scan = TAIL(DC(class)->cpl); scan != obj_Nil; scan = TAIL(scan)) {
  806.     obj_t super = HEAD(scan);
  807.     if (obj_ptr(struct class *, super)->class == obj_DefinedClassClass) {
  808.         for (slots=DC(super)->new_slots;slots!=obj_Nil;slots=TAIL(slots)) {
  809.         switch (SD(HEAD(slots))->alloc) {
  810.           case alloc_INSTANCE:
  811.             instance_length++;
  812.             break;
  813.           case alloc_SUBCLASS:
  814.             subclass_length++;
  815.             break;
  816.           case alloc_CLASS:
  817.           case alloc_CONSTANT:
  818.           case alloc_VIRTUAL:
  819.             break;
  820.           default:
  821.             lose("Strange slot allocation.");
  822.         }
  823.         }
  824.     }
  825.     }
  826.  
  827.     for (slots = DC(class)->new_slots; slots != obj_Nil; slots = TAIL(slots)) {
  828.     obj_t slot = HEAD(slots);
  829.     switch (SD(slot)->alloc) {
  830.       case alloc_INSTANCE:
  831.         SD(slot)->desired_offset = instance_length++;
  832.         break;
  833.       case alloc_SUBCLASS:
  834.         SD(slot)->desired_offset = subclass_length++;
  835.         break;
  836.       case alloc_CLASS:
  837.       case alloc_CONSTANT:
  838.       case alloc_VIRTUAL:
  839.         break;
  840.       default:
  841.         lose("Strange slot allocation.");
  842.     }
  843.     }
  844.  
  845.     DC(class)->instance_length = instance_length;
  846.     layout = make_vector(instance_length, NULL);
  847.     DC(class)->instance_layout = layout;
  848.     for (i = 0; i < instance_length; i++)
  849.     SOVEC(layout)->contents[i] = obj_False;
  850.  
  851.     if (subclass_length > 0) {
  852.     obj_t slots = make_vector(subclass_length, NULL);
  853.     DC(class)->subclass_slots = slots;
  854.     layout = make_vector(subclass_length, NULL);
  855.     DC(class)->subclass_layout = layout;
  856.     for (i = 0; i < subclass_length; i++) {
  857.         SOVEC(layout)->contents[i] = obj_False;
  858.         SOVEC(slots)->contents[i] = obj_Unbound;
  859.     }
  860.     }
  861. }
  862.  
  863.  
  864. /* Process Slot Specifications */
  865.  
  866. static void add_slot(obj_t class, obj_t new_slot, boolean inherited)
  867. {
  868.     obj_t new_getter = SD(new_slot)->getter;
  869.     obj_t new_setter = SD(new_slot)->setter;
  870.     obj_t slots;
  871.  
  872.     for (slots = DC(class)->all_slots; slots != obj_Nil; slots = TAIL(slots)) {
  873.     obj_t slot = HEAD(slots);
  874.     obj_t getter = SD(slot)->getter;
  875.     obj_t setter = SD(slot)->setter;
  876.  
  877.     if (new_getter == getter)
  878.         if (inherited)
  879.         error("Can't inherit slot %= from both %= and %=",
  880.               function_debug_name_or_self(getter), SD(slot)->creator,
  881.               SD(new_slot)->creator);
  882.         else
  883.         error("Slot %= in %= clashes with the slot inherited from %=",
  884.               function_debug_name_or_self(getter), class,
  885.               SD(slot)->creator);
  886.     if (new_getter == setter)
  887.         if (inherited)
  888.         error("The getter for slot %= inherited from %= clashes with "
  889.               "the setter for slot %= inherited from %=",
  890.               function_debug_name_or_self(new_getter),
  891.               SD(new_slot)->creator,
  892.               function_debug_name_or_self(getter), SD(slot)->creator);
  893.         else
  894.         error("The getter for slot %= in %= clashes with "
  895.               "the setter for slot %= inherited from %=",
  896.               function_debug_name_or_self(new_getter), class,
  897.               function_debug_name_or_self(getter), SD(slot)->creator);
  898.     if (new_setter != obj_False) {
  899.         if (new_setter == getter)
  900.         if (inherited)
  901.             error("The setter for slot %= inherited from %= clashes "
  902.               "with the getter for slot %= inherited from %=",
  903.               function_debug_name_or_self(new_getter),
  904.               SD(new_slot)->creator,
  905.               function_debug_name_or_self(getter),
  906.               SD(slot)->creator);
  907.         else
  908.             error("The setter for slot %= in %= clashes "
  909.               "with the getter for slot %= inherited from %=",
  910.               function_debug_name_or_self(new_getter), class,
  911.               function_debug_name_or_self(getter),
  912.               SD(slot)->creator);
  913.         if (new_setter == setter)
  914.         if (inherited)
  915.             error("The setter for slot %= inherited from %= clashes "
  916.               "with the setter for slot %= inherited from %=",
  917.               function_debug_name_or_self(new_getter),
  918.               SD(new_slot)->creator,
  919.               function_debug_name_or_self(getter),
  920.               SD(slot)->creator);
  921.         else
  922.             error("The setter for slot %= in %= clashes "
  923.               "with the setter for slot %= inherited from %=",
  924.               function_debug_name_or_self(new_getter), class,
  925.               function_debug_name_or_self(getter),
  926.               SD(slot)->creator);
  927.     }
  928.     }
  929.  
  930.     DC(class)->all_slots = pair(new_slot, DC(class)->all_slots);
  931. }
  932.  
  933. static obj_t classes_processed;
  934. static obj_t displaced_instance_slots;
  935. static obj_t displaced_subclass_slots;
  936. static obj_t initializers;
  937.  
  938. static void inherit_slots(obj_t class, obj_t super)
  939. {
  940.     obj_t supers, new_slots;
  941.  
  942.     if (memq(super, classes_processed))
  943.     return;
  944.     classes_processed = pair(super, classes_processed);
  945.  
  946.     if (obj_ptr(struct class *, super)->class != obj_DefinedClassClass)
  947.     return;
  948.  
  949.     for (supers=DC(super)->superclasses; supers!=obj_Nil; supers=TAIL(supers))
  950.     inherit_slots(class, HEAD(supers));
  951.  
  952.     for (new_slots = DC(super)->new_slots;
  953.      new_slots != obj_Nil;
  954.      new_slots = TAIL(new_slots)) {
  955.     obj_t new_slot = HEAD(new_slots);
  956.  
  957.     add_slot(class, new_slot, TRUE);
  958.  
  959.     switch (SD(new_slot)->alloc) {
  960.         int offset;
  961.       case alloc_INSTANCE:
  962.         offset = SD(new_slot)->desired_offset;
  963.         if (SOVEC(DC(class)->instance_layout)->contents[offset]
  964.           != obj_False)
  965.         displaced_instance_slots
  966.             = pair(new_slot, displaced_instance_slots);
  967.         else
  968.         SOVEC(DC(class)->instance_layout)->contents[offset] = new_slot;
  969.         break;
  970.  
  971.       case alloc_SUBCLASS:
  972.         offset = SD(new_slot)->desired_offset;
  973.         if (SOVEC(DC(class)->subclass_layout)->contents[offset]
  974.           != obj_False)
  975.         displaced_subclass_slots
  976.             = pair(new_slot, displaced_subclass_slots);
  977.         else {
  978.         SOVEC(DC(class)->subclass_layout)->contents[offset] = new_slot;
  979.         initializers = pair(slot_initializer(new_slot), initializers);
  980.         }
  981.         break;
  982.  
  983.       case alloc_CLASS:
  984.       case alloc_CONSTANT:
  985.       case alloc_VIRTUAL:
  986.         /* We don't need to do anything to inherit these. */
  987.         break;
  988.  
  989.       default:
  990.         lose("Strange slot allocation.");
  991.     }
  992.     }
  993. }
  994.  
  995. static obj_t compute_positions(obj_t displaced_slots, obj_t layout)
  996. {
  997.     int index = 0;
  998.     obj_t res;
  999.  
  1000.     if (displaced_slots == obj_Nil)
  1001.     return obj_False;
  1002.  
  1003.     res = make_position_table();
  1004.     while (displaced_slots != obj_Nil) {
  1005.     obj_t slot = HEAD(displaced_slots);
  1006.     while (SOVEC(layout)->contents[index] != obj_False)
  1007.         index++;
  1008.     SOVEC(layout)->contents[index] = slot;
  1009.     note_position(res, slot, index);
  1010.     displaced_slots = TAIL(displaced_slots);
  1011.     }
  1012.  
  1013.     return res;
  1014. }
  1015.  
  1016. static void process_slot(obj_t class, obj_t slot)
  1017. {
  1018.     int offset = SD(slot)->desired_offset;
  1019.     obj_t value_cell;
  1020.  
  1021.     SD(slot)->creator = class;
  1022.  
  1023.     add_slot(class, slot, FALSE);
  1024.  
  1025.     switch (SD(slot)->alloc) {
  1026.       case alloc_INSTANCE:
  1027.     SOVEC(DC(class)->instance_layout)->contents[offset] = slot;
  1028.     SD(slot)->getter_method
  1029.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1030.                    class, SD(slot)->type,
  1031.                    FALSE, make_fixnum(offset),
  1032.                    fast_instance_getter);
  1033.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1034.     if (SD(slot)->setter != obj_False) {
  1035.         SD(slot)->setter_method
  1036.         = make_accessor_method(function_debug_name(SD(slot)->setter),
  1037.                        class, SD(slot)->type,
  1038.                        TRUE, make_fixnum(offset),
  1039.                        fast_instance_setter);
  1040.         add_method(SD(slot)->setter, SD(slot)->setter_method);
  1041.     }
  1042.     break;
  1043.  
  1044.       case alloc_SUBCLASS:
  1045.     SOVEC(DC(class)->subclass_layout)->contents[offset] = slot;
  1046.     initializers = pair(slot_initializer(slot), initializers);
  1047.     SD(slot)->getter_method
  1048.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1049.                    class, SD(slot)->type,
  1050.                    FALSE, make_fixnum(offset),
  1051.                    fast_subclass_getter);
  1052.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1053.     if (SD(slot)->setter != obj_False) {
  1054.         SD(slot)->setter_method
  1055.         = make_accessor_method(function_debug_name(SD(slot)->setter),
  1056.                        class, SD(slot)->type, TRUE,
  1057.                        make_fixnum(offset),
  1058.                        fast_subclass_setter);
  1059.         add_method(SD(slot)->setter, SD(slot)->setter_method);
  1060.     }
  1061.     break;
  1062.  
  1063.       case alloc_CLASS:
  1064.     value_cell = make_value_cell(obj_Unbound);
  1065.     initializers = pair(slot_initializer(slot), initializers);
  1066.     SD(slot)->getter_method
  1067.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1068.                    class, SD(slot)->type,
  1069.                    FALSE, value_cell, class_getter);
  1070.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1071.     if (SD(slot)->setter != obj_False) {
  1072.         SD(slot)->setter_method
  1073.         = make_accessor_method(function_debug_name(SD(slot)->setter),
  1074.                        class, SD(slot)->type,
  1075.                        TRUE, value_cell, class_setter);
  1076.         add_method(SD(slot)->setter, SD(slot)->setter_method);
  1077.     }
  1078.     break;
  1079.  
  1080.       case alloc_CONSTANT:
  1081.     SD(slot)->getter_method
  1082.         = make_accessor_method(function_debug_name(SD(slot)->getter),
  1083.                    class, SD(slot)->type,
  1084.                    FALSE, SD(slot)->init_function_or_value,
  1085.                    constant_getter);
  1086.     add_method(SD(slot)->getter, SD(slot)->getter_method);
  1087.     break;
  1088.  
  1089.       case alloc_VIRTUAL:
  1090.     /* Don't need to add any methods. */
  1091.     break;
  1092.  
  1093.       default:
  1094.     lose("Strange slot allocation.");
  1095.     }
  1096. }
  1097.  
  1098.  
  1099. /* Process Initarg Specifications */
  1100.  
  1101. #define conflicting_initargs(initarg1, initarg2) \
  1102.     (INTD(initarg1)->type != INTD(initarg2)->type \
  1103.      || INTD(initarg1)->required_p != INTD(initarg2)->required_p \
  1104.      || INTD(initarg1)->init_function_or_value \
  1105.        != INTD(initarg2)->init_function_or_value)
  1106.  
  1107. static void inherit_initargs(obj_t class, obj_t super)
  1108. {
  1109.     obj_t inh_initargs;
  1110.     obj_t new_initargs;
  1111.     obj_t all_initargs;
  1112.  
  1113.     if (obj_ptr(struct class *, super)->class != obj_DefinedClassClass)
  1114.         return;
  1115.  
  1116.     for (inh_initargs = DC(super)->new_initargs; inh_initargs != obj_Nil;
  1117.      inh_initargs = TAIL(inh_initargs)) {
  1118.     obj_t inh_initarg = HEAD(inh_initargs);
  1119.     boolean redefined = FALSE;
  1120.     boolean inherited = FALSE;
  1121.  
  1122.     for (new_initargs = DC(class)->new_initargs; new_initargs != obj_Nil;
  1123.          new_initargs = TAIL(new_initargs)) {
  1124.         obj_t initarg = HEAD(new_initargs);
  1125.  
  1126.         if (INTD(inh_initarg)->keyword == INTD(initarg)->keyword) {
  1127.         /* Check that the type is a subtype of the inherited */
  1128.         if (!subtypep(INTD(initarg)->type, INTD(inh_initarg)->type))
  1129.             error("Incompatible init arg type for %=.",
  1130.               INTD(initarg)->keyword);
  1131.         /* Determine whether initarg is required */
  1132.         if (INTD(inh_initarg)->required_p
  1133.               && INTD(initarg)->init_function_or_value == obj_Unbound)
  1134.             INTD(initarg)->required_p = TRUE;
  1135.         redefined = TRUE;
  1136.         break;
  1137.         }
  1138.     }
  1139.     if (redefined)
  1140.         break;
  1141.     for (all_initargs = DC(class)->all_initargs; all_initargs != obj_Nil;
  1142.          all_initargs = TAIL(all_initargs)) {
  1143.         obj_t initarg = HEAD(all_initargs);
  1144.  
  1145.         if (INTD(inh_initarg)->keyword == INTD(initarg)->keyword) {
  1146.         /* Determine whether definitions are the same */
  1147.         if (conflicting_initargs(inh_initarg, initarg))
  1148.             error("Conflicting inherited definitions of init arg %=",
  1149.               INTD(initarg)->keyword);
  1150.         inherited = TRUE;
  1151.         }
  1152.     }
  1153.     if (!redefined && !inherited) {
  1154.         DC(class)->all_initargs =
  1155.           pair(inh_initarg, DC(class)->all_initargs);
  1156.     }
  1157.     }
  1158. }
  1159.  
  1160.  
  1161. /* Process Inherited Specifications */
  1162.  
  1163. static void process_inherited(obj_t class, obj_t inherited)
  1164. {
  1165.     obj_t slots;
  1166.  
  1167.     for (slots = DC(class)->all_slots; slots != obj_Nil; slots = TAIL(slots)) {
  1168.     obj_t slot = HEAD(slots);
  1169.     obj_t inits;
  1170.  
  1171.     if (SD(slot)->name == INHD(inherited)->name) {
  1172.         switch (SD(slot)->alloc) {
  1173.           case alloc_INSTANCE:
  1174.         break;
  1175.           case alloc_SUBCLASS:
  1176.         for (inits = initializers; inits != obj_Nil;
  1177.              inits = TAIL(inits)) {
  1178.             obj_t init = HEAD(inits);
  1179.  
  1180.             if (INITIALIZER(init)->slot == slot) {
  1181.                 HEAD(inits) = inherited_initializer(slot, inherited);
  1182.             break;
  1183.             }
  1184.         }
  1185.         if (inits == obj_Nil) {
  1186.             initializers
  1187.               = pair(inherited_initializer(slot, inherited),
  1188.                  initializers);
  1189.         }
  1190.         break;
  1191.           case alloc_CLASS:
  1192.         if (INHD(inherited)->init_function_or_value != obj_Unbound)
  1193.           error("Can't init inherited class slot %=",
  1194.             INHD(inherited)->name);
  1195.         break;
  1196.           case alloc_CONSTANT:
  1197.         if (INHD(inherited)->init_function_or_value != obj_Unbound)
  1198.           error("Can't init inherited constant slot %=",
  1199.             INHD(inherited)->name);
  1200.         break;
  1201.           case alloc_VIRTUAL:
  1202.         if (INHD(inherited)->init_function_or_value != obj_Unbound)
  1203.             error("Can't init inherited virtual slot %=",
  1204.               INHD(inherited)->name);
  1205.         break;
  1206.           default:
  1207.         lose("Strange slot allocation.");
  1208.         }
  1209.         return;
  1210.     }
  1211.     }
  1212.     error("Slot %= not inherited from any superclass",
  1213.       INHD(inherited)->name);
  1214. }
  1215.  
  1216.  
  1217. /* Initialize Defined Class */
  1218.  
  1219. void init_defined_class(obj_t class, obj_t slots,
  1220.             obj_t initargs, obj_t inheriteds)
  1221. {
  1222.     obj_t scan;
  1223.  
  1224.     if (object_class(class) != obj_DefinedClassClass) {
  1225.     if (slots != obj_Nil)
  1226.         error("Cannot add slots to %= classes", object_class(class));
  1227.     do_initialization(class, obj_Nil, obj_Nil);
  1228.     }
  1229.  
  1230.     DC(class)->new_slots = slots;
  1231.     DC(class)->all_slots = obj_Nil;
  1232.     DC(class)->new_initargs = initargs;
  1233.     DC(class)->all_initargs = initargs;
  1234.     DC(class)->inheriteds = inheriteds;
  1235.  
  1236.     compute_lengths(class);
  1237.  
  1238.     /* Process Slots */
  1239.  
  1240.     classes_processed = obj_Nil;
  1241.     displaced_instance_slots = obj_Nil;
  1242.     displaced_subclass_slots = obj_Nil;
  1243.     initializers = obj_Nil;
  1244.  
  1245.     for (scan = DC(class)->superclasses; scan != obj_Nil; scan = TAIL(scan))
  1246.     inherit_slots(class, HEAD(scan));
  1247.  
  1248.     DC(class)->instance_positions
  1249.     = compute_positions(displaced_instance_slots,
  1250.                 DC(class)->instance_layout);
  1251.     DC(class)->subclass_positions
  1252.     = compute_positions(displaced_subclass_slots,
  1253.                 DC(class)->subclass_layout);
  1254.  
  1255.     classes_processed = NULL;
  1256.     displaced_instance_slots = NULL;
  1257.     displaced_subclass_slots = NULL;
  1258.  
  1259.     for (scan = slots; scan != obj_Nil; scan = TAIL(scan))
  1260.     process_slot(class, HEAD(scan));
  1261.  
  1262.     /* Process Initargs */
  1263.  
  1264.     for (scan = TAIL(DC(class)->cpl); scan != obj_Nil; scan = TAIL(scan))
  1265.     inherit_initargs(class, HEAD(scan));
  1266.  
  1267.     /* Process Inheriteds */
  1268.  
  1269.     for (scan = inheriteds; scan != obj_Nil; scan = TAIL(scan))
  1270.         process_inherited(class, HEAD(scan));
  1271.  
  1272.     scan = initializers;
  1273.     initializers = NULL;
  1274.     do_initialization(class, obj_Nil, scan);
  1275. }
  1276.     
  1277.  
  1278. /* Make and Initialize Instances */
  1279.  
  1280. static obj_t dylan_make(obj_t class, obj_t key_and_value_pairs)
  1281. {
  1282.     error("Can't make instances of %= with the default make method.",
  1283.       class);
  1284.     return NULL;
  1285. }
  1286.  
  1287. static obj_t defaulted_initargs(obj_t class, obj_t keyword_arg_pairs)
  1288. {
  1289.     int i;
  1290.     int nkeys = SOVEC(keyword_arg_pairs)->length;
  1291.     obj_t supplied_initargs = obj_Nil;
  1292.     obj_t defaulted_initargs;
  1293.     obj_t supplieds;
  1294.     obj_t initargs;
  1295.  
  1296.     /* Get the supplied initialization arguments */
  1297.  
  1298.     for (i = 0; i < nkeys; i += 2) {
  1299.     obj_t initarg =
  1300.       make_initarg_descr(SOVEC(keyword_arg_pairs)->contents[i],
  1301.                  obj_False, obj_False, obj_Unbound,
  1302.                  SOVEC(keyword_arg_pairs)->contents[i+1]);
  1303.     supplied_initargs = pair(initarg, supplied_initargs);
  1304.     }
  1305.  
  1306.     /* Augment supplied initialization arguments with defaults */
  1307.  
  1308.     defaulted_initargs = supplied_initargs;
  1309.  
  1310.     for (initargs = DC(class)->all_initargs; initargs != obj_Nil;
  1311.      initargs = TAIL(initargs)) {
  1312.     obj_t initarg = HEAD(initargs);
  1313.     boolean found = FALSE;
  1314.  
  1315.     for (supplieds = supplied_initargs; supplieds != obj_Nil;
  1316.          supplieds = TAIL(supplieds)) {
  1317.         obj_t supplied = HEAD(supplieds);
  1318.  
  1319.         if (INTD(initarg)->keyword == INTD(supplied)->keyword) {
  1320.         if (!instancep(INTD(supplied)->init_function_or_value,
  1321.                    INTD(initarg)->type))
  1322.             error("Keyword arg %= must have type %=",
  1323.               INTD(initarg)->keyword, INTD(initarg)->type);
  1324.             found = TRUE;
  1325.         break;
  1326.         }
  1327.     }
  1328.     if (!found) {
  1329.         if (INTD(initarg)->required_p)
  1330.             error("Required init arg %= not supplied",
  1331.               INTD(initarg)->keyword);
  1332.         else
  1333.         defaulted_initargs = pair(initarg, defaulted_initargs);
  1334.     }
  1335.     }
  1336.     return defaulted_initargs;
  1337. }
  1338.  
  1339. static obj_t dylan_make_instance(obj_t class, obj_t keyword_arg_pairs)
  1340. {
  1341.     int length = DC(class)->instance_length;
  1342.     obj_t res = alloc(class,
  1343.               sizeof(struct instance) + (length - 1) * sizeof(obj_t));
  1344.     obj_t default_initargs;
  1345.     obj_t slots;
  1346.     obj_t initargs;
  1347.     obj_t inits;
  1348.     int i;
  1349.  
  1350.     /* Fill the instance in with something so that the garbage collector */
  1351.     /* doesn't get annoyed. */
  1352.     for (i = 0; i < length; i++)
  1353.     INST(res)->slots[i] = obj_Unbound;
  1354.  
  1355.     if (DC(class)->all_slots == obj_False)
  1356.     error("Attempt to make an instance of %= before\n"
  1357.           "the define class for it has been processed.",
  1358.           class);
  1359.  
  1360.     initializers = obj_Nil;
  1361.  
  1362.     default_initargs = defaulted_initargs(class, keyword_arg_pairs);
  1363.  
  1364.     for (slots = DC(class)->all_slots; slots != obj_Nil; slots = TAIL(slots)) {
  1365.     obj_t slot = HEAD(slots);
  1366.     boolean slot_initialized_p = FALSE;
  1367.     obj_t keyword = SD(slot)->init_keyword;
  1368.  
  1369.     /* Check for keyword init value */
  1370.  
  1371.     if (keyword != obj_False && !slot_initialized_p) {
  1372.         obj_t initargs;
  1373.         boolean suppliedp = FALSE;
  1374.  
  1375.         for (initargs = default_initargs; initargs != obj_Nil;
  1376.          initargs = TAIL(initargs)) {
  1377.         obj_t initarg = HEAD(initargs);
  1378.  
  1379.         if (INTD(initarg)->keyword == keyword) {
  1380.             obj_t initializer
  1381.               = initarg_slot_initializer(slot, initarg);
  1382.  
  1383.             INTD(initarg)->initializer = initializer;
  1384.             initializers = pair(initializer, initializers);
  1385.             slot_initialized_p = TRUE;
  1386.             suppliedp = TRUE;
  1387.             break;
  1388.         }
  1389.         }
  1390.         if (SD(slot)->keyword_required && !suppliedp)
  1391.         error("Missing required init-keyword %=", keyword);
  1392.     }
  1393.  
  1394.     /* Check for inherited spec init value */
  1395.  
  1396.     if (!slot_initialized_p) {
  1397.         obj_t inheriteds;
  1398.  
  1399.         for (inheriteds = DC(class)->inheriteds; inheriteds != obj_Nil;
  1400.          inheriteds = TAIL(inheriteds)) {
  1401.         obj_t inherited = HEAD(inheriteds);
  1402.         
  1403.         if (SD(slot)->name == INHD(inherited)->name
  1404.               && SD(slot)->alloc == alloc_INSTANCE) {
  1405.             obj_t initializer
  1406.               = inherited_initializer(slot, inherited);
  1407.  
  1408.             initializers = pair(initializer, initializers);
  1409.             slot_initialized_p = TRUE;
  1410.             break;
  1411.         }
  1412.         }
  1413.     }
  1414.  
  1415.     /* Check for slot spec init value */
  1416.  
  1417.     if (!slot_initialized_p && SD(slot)->alloc == alloc_INSTANCE) {
  1418.         obj_t initializer = slot_initializer(slot);
  1419.  
  1420.         initializers = pair(initializer, initializers);
  1421.         slot_initialized_p = TRUE;
  1422.     }
  1423.     }
  1424.  
  1425.     for (initargs = default_initargs; initargs != obj_Nil;
  1426.      initargs = TAIL(initargs)) {
  1427.     obj_t initarg = HEAD(initargs);
  1428.  
  1429.     if (INTD(initarg)->initializer == obj_False) {
  1430.         obj_t initializer = initarg_initializer(initarg);
  1431.  
  1432.         INTD(initarg)->initializer = initializer;
  1433.         initializers = pair(initializer, initializers);
  1434.     }
  1435.     }
  1436.  
  1437.     inits = initializers;
  1438.     initializers = NULL;
  1439.     do_initialization(res, default_initargs, inits);
  1440.  
  1441.     return NULL;
  1442. }
  1443.  
  1444. static obj_t dylan_init(obj_t object, obj_t key_val_pairs)
  1445. {
  1446.     return obj_False;
  1447. }
  1448.  
  1449.  
  1450.  
  1451. /* Other routines. */
  1452.  
  1453. static obj_t dylan_slot_initialized_p(obj_t instance, obj_t getter)
  1454. {
  1455.     obj_t class = object_class(instance);
  1456.     obj_t scan, slot;
  1457.     int index;
  1458.     obj_t value = NULL;
  1459.  
  1460.     if (object_class(class) != obj_DefinedClassClass)
  1461.     error("%= doesn't access a slot in %=", getter, instance);
  1462.  
  1463.     for (scan = DC(class)->all_slots; scan != obj_Nil; scan = TAIL(scan)) {
  1464.     slot = HEAD(scan);
  1465.     if (SD(slot)->getter == getter) {
  1466.         switch (SD(slot)->alloc) {
  1467.           case alloc_INSTANCE:
  1468.         index = find_position(DC(class)->instance_positions, slot);
  1469.         value = INST(instance)->slots[index];
  1470.         break;
  1471.           case alloc_SUBCLASS:
  1472.         index = find_position(DC(class)->subclass_positions, slot);
  1473.         value = INST(instance)->slots[index];
  1474.         break;
  1475.           case alloc_CLASS:
  1476.         value = value_cell_ref(accessor_method_datum
  1477.                        (SD(slot)->getter_method));
  1478.         break;
  1479.           case alloc_CONSTANT:
  1480.         value = accessor_method_datum(SD(slot)->getter_method);
  1481.         break;
  1482.           case alloc_VIRTUAL:
  1483.         value = obj_False;
  1484.         break;
  1485.           default:
  1486.         lose("Strange slot allocation.");
  1487.         }
  1488.         if (value == obj_Unbound)
  1489.         return obj_False;
  1490.         else
  1491.         return obj_True;
  1492.     }
  1493.     }
  1494.  
  1495.     error("%= doesn't access a slot in %=", getter, instance);    
  1496.     return NULL;
  1497. }
  1498.  
  1499.  
  1500. /* Introspection stuff. */
  1501.  
  1502. static obj_t dylan_class_slot_descriptors(obj_t class)
  1503. {
  1504.     return obj_Nil;
  1505. }
  1506.  
  1507. static obj_t dylan_dc_slot_descriptors(obj_t class)
  1508. {
  1509.     return DC(class)->all_slots;
  1510. }
  1511.  
  1512. static obj_t dylan_slot_name(obj_t slot)
  1513. {
  1514.     return SD(slot)->name;
  1515. }
  1516.  
  1517. static obj_t dylan_slot_alloc(obj_t slot)
  1518. {
  1519.     switch (SD(slot)->alloc) {
  1520.       case alloc_INSTANCE:
  1521.     return symbol("instance");
  1522.       case alloc_CLASS:
  1523.     return symbol("class");
  1524.       case alloc_SUBCLASS:
  1525.     return symbol("subclass");
  1526.       case alloc_CONSTANT:
  1527.     return symbol("constant");
  1528.       case alloc_VIRTUAL:
  1529.     return symbol("virtual");
  1530.       default:
  1531.     lose("Bogus kind of allocation in slot descriptor");
  1532.     return obj_False;
  1533.     }
  1534. }
  1535.  
  1536. static obj_t dylan_slot_getter(obj_t slot)
  1537. {
  1538.     return SD(slot)->getter;
  1539. }
  1540.  
  1541. static obj_t dylan_slot_getter_method(obj_t slot)
  1542. {
  1543.     return SD(slot)->getter_method;
  1544. }
  1545.  
  1546. static obj_t dylan_slot_setter(obj_t slot)
  1547. {
  1548.     return SD(slot)->setter;
  1549. }
  1550.  
  1551. static obj_t dylan_slot_setter_method(obj_t slot)
  1552. {
  1553.     return SD(slot)->setter_method;
  1554. }
  1555.  
  1556. static obj_t dylan_slot_type(obj_t slot)
  1557. {
  1558.     return SD(slot)->type;
  1559. }
  1560.  
  1561. static void dylan_slot_value(obj_t self, struct thread *thread, obj_t *args)
  1562. {
  1563.     obj_t *old_sp = args - 1;
  1564.     obj_t slot = args[0];
  1565.     obj_t instance = args[1];
  1566.     obj_t class = object_class(instance);
  1567.     int index;
  1568.     obj_t value;
  1569.  
  1570.     if (!instancep(instance, SD(slot)->creator))
  1571.     error("%= is not one of %='s slots", slot, instance);
  1572.  
  1573.     switch (SD(slot)->alloc) {
  1574.       case alloc_INSTANCE:
  1575.     index = find_position(DC(class)->instance_positions, slot);
  1576.     value = INST(instance)->slots[index];
  1577.     break;
  1578.       case alloc_SUBCLASS:
  1579.     index = find_position(DC(class)->subclass_positions, slot);
  1580.     value = INST(instance)->slots[index];
  1581.     break;
  1582.       case alloc_CLASS:
  1583.     value = value_cell_ref(accessor_method_datum
  1584.                    (SD(slot)->getter_method));
  1585.     break;
  1586.       case alloc_CONSTANT:
  1587.     value = accessor_method_datum(SD(slot)->getter_method);
  1588.     break;
  1589.       case alloc_VIRTUAL:
  1590.     value = obj_Unbound;
  1591.     break;
  1592.       default:
  1593.     lose("Strange slot allocation.");
  1594.     }
  1595.  
  1596.     thread->sp = old_sp + 2;
  1597.  
  1598.     if (value == obj_Unbound) {
  1599.     old_sp[0] = obj_False;
  1600.     old_sp[1] = obj_False;
  1601.     }
  1602.     else {
  1603.     old_sp[0] = value;
  1604.     old_sp[1] = obj_True;
  1605.     }
  1606.     
  1607.     do_return(thread, old_sp, old_sp);
  1608. }
  1609.  
  1610. static obj_t dylan_slot_value_setter(obj_t value, obj_t slot, obj_t instance)
  1611. {
  1612.     obj_t class = object_class(instance);
  1613.     int index;
  1614.  
  1615.     if (!instancep(instance, SD(slot)->creator))
  1616.     error("%= is not one of %='s slots", slot, instance);
  1617.  
  1618.     check_type(value, SD(slot)->type);
  1619.  
  1620.     switch (SD(slot)->alloc) {
  1621.       case alloc_INSTANCE:
  1622.     index = find_position(DC(class)->instance_positions, slot);
  1623.     INST(instance)->slots[index] = value;
  1624.     break;
  1625.       case alloc_SUBCLASS:
  1626.     index = find_position(DC(class)->subclass_positions, slot);
  1627.     INST(instance)->slots[index] = value;
  1628.     break;
  1629.       case alloc_CLASS:
  1630.     value_cell_set(accessor_method_datum(SD(slot)->getter_method), value);
  1631.     break;
  1632.       case alloc_CONSTANT:
  1633.     error("constant slots cannot be set.");
  1634.     break;
  1635.       case alloc_VIRTUAL:
  1636.     error("virtual slots cannot be set.");
  1637.     break;
  1638.       default:
  1639.     lose("Strange slot allocation.");
  1640.     }
  1641.  
  1642.     return value;
  1643. }
  1644.  
  1645.  
  1646. /* Describe. */
  1647.  
  1648. void describe(obj_t thing)
  1649. {
  1650.     obj_t class = object_class(thing);
  1651.     obj_t slots;
  1652.  
  1653.     prin1(thing);
  1654.     printf(" is an instance of ");
  1655.     print(class);
  1656.  
  1657.     if (object_class(class) == obj_DefinedClassClass) {
  1658.     printf("and has the following slots:\n");
  1659.  
  1660.     for (slots=DC(class)->all_slots; slots != obj_Nil; slots=TAIL(slots)) {
  1661.         obj_t slot = HEAD(slots);
  1662.         int index, dummy;
  1663.         obj_t value;
  1664.  
  1665.         fputs(sym_name(SD(slot)->name), stdout);
  1666.         switch (SD(slot)->alloc) {
  1667.           case alloc_INSTANCE:
  1668.         index = find_position(DC(class)->instance_positions, slot);
  1669.         value = INST(thing)->slots[index];
  1670.         break;
  1671.           case alloc_SUBCLASS:
  1672.         printf("[each subclass]");
  1673.         index = find_position(DC(class)->subclass_positions, slot);
  1674.         value = INST(thing)->slots[index];
  1675.         break;
  1676.           case alloc_CLASS:
  1677.         value = value_cell_ref(accessor_method_datum
  1678.                        (SD(slot)->getter_method));
  1679.         printf("[class]");
  1680.         break;
  1681.           case alloc_CONSTANT:
  1682.         value = accessor_method_datum(SD(slot)->getter_method);
  1683.         printf("[constant]");
  1684.         break;
  1685.           case alloc_VIRTUAL:
  1686.         printf("[virtual]\n");
  1687.         goto after_value_printing;
  1688.           default:
  1689.         lose("Strange slot allocation.");
  1690.         }
  1691.  
  1692.         if (value == obj_Unbound)
  1693.         printf(" is unbound\n");
  1694.         else {
  1695.         printf(": ");
  1696.         print(value);
  1697.         }
  1698.       after_value_printing:
  1699.         dummy = 0;    /* Without this line, a few compilers will choke */
  1700.     }
  1701.     }
  1702. }
  1703.  
  1704.  
  1705. /* GC routines. */
  1706.  
  1707. static int scav_defined_class(struct object *ptr)
  1708. {
  1709.     struct defined_class *class = (struct defined_class *)ptr;
  1710.  
  1711.     scavenge(&class->debug_name);
  1712.     scavenge(&class->superclasses);
  1713.     scavenge(&class->cpl);
  1714.     scavenge(&class->direct_subclasses);
  1715.     scavenge(&class->all_subclasses);
  1716.     scavenge(&class->new_slots);
  1717.     scavenge(&class->all_slots);
  1718.     scavenge(&class->new_initargs);
  1719.     scavenge(&class->all_initargs);
  1720.     scavenge(&class->inheriteds);
  1721.     scavenge(&class->instance_positions);
  1722.     scavenge(&class->instance_layout);
  1723.     scavenge(&class->subclass_positions);
  1724.     scavenge(&class->subclass_slots);
  1725.     scavenge(&class->subclass_layout);
  1726.  
  1727.     return sizeof(struct defined_class);
  1728. }
  1729.  
  1730. static obj_t trans_defined_class(obj_t class)
  1731. {
  1732.     return transport(class, sizeof(struct defined_class));
  1733. }
  1734.  
  1735. static int scav_slot_descr(struct object *ptr)
  1736. {
  1737.     struct slot_descr *slot = (struct slot_descr *)ptr;
  1738.  
  1739.     scavenge(&slot->name);
  1740.     scavenge(&slot->creator);
  1741.     scavenge(&slot->init_function_or_value);
  1742.     scavenge(&slot->init_keyword);
  1743.     scavenge(&slot->getter);
  1744.     scavenge(&slot->getter_method);
  1745.     scavenge(&slot->setter);
  1746.     scavenge(&slot->setter_method);
  1747.     scavenge(&slot->type);
  1748.  
  1749.     return sizeof(struct slot_descr);
  1750. }
  1751.  
  1752. static obj_t trans_slot_descr(obj_t slot)
  1753. {
  1754.     return transport(slot, sizeof(struct slot_descr));
  1755. }
  1756.  
  1757. static int scav_initarg_descr(struct object *ptr)
  1758. {
  1759.     struct initarg_descr *initarg = (struct initarg_descr *)ptr;
  1760.  
  1761.     scavenge(&initarg->keyword);
  1762.     scavenge(&initarg->type);
  1763.     scavenge(&initarg->init_function_or_value);
  1764.  
  1765.     return sizeof(struct initarg_descr);
  1766. }
  1767.  
  1768. static obj_t trans_initarg_descr(obj_t initarg)
  1769. {
  1770.     return transport(initarg, sizeof(struct initarg_descr));
  1771. }
  1772.  
  1773. static int scav_inherited_descr(struct object *ptr)
  1774. {
  1775.     struct inherited_descr *inherited = (struct inherited_descr *)ptr;
  1776.  
  1777.     scavenge(&inherited->name);
  1778.     scavenge(&inherited->init_function_or_value);
  1779.  
  1780.     return sizeof(struct inherited_descr);
  1781. }
  1782.  
  1783. static obj_t trans_inherited_descr(obj_t inherited)
  1784. {
  1785.     return transport(inherited, sizeof(struct inherited_descr));
  1786. }
  1787.  
  1788. static int scav_postable(struct object *ptr)
  1789. {
  1790.     struct postable *p = (struct postable *)ptr;
  1791.  
  1792.     scavenge(&p->alist);
  1793.  
  1794.     return sizeof(struct postable);
  1795. }
  1796.  
  1797. static obj_t trans_postable(obj_t p)
  1798. {
  1799.     return transport(p, sizeof(struct postable));
  1800. }
  1801.  
  1802. static int scav_initializer(struct object *ptr)
  1803. {
  1804.     struct initializer *p = (struct initializer *)ptr;
  1805.  
  1806.     scavenge(&p->slot);
  1807.     scavenge(&p->initarg);
  1808.     scavenge(&p->inherited);
  1809.  
  1810.     return sizeof(struct initializer);
  1811. }
  1812.  
  1813. static obj_t trans_initializer(obj_t p)
  1814. {
  1815.     return transport(p, sizeof(struct initializer));
  1816. }
  1817.  
  1818. static int scav_instance(struct object *ptr)
  1819. {
  1820.     struct instance *instance = (struct instance *)ptr;
  1821.     int nslots = DC(ptr->class)->instance_length;
  1822.     int i;
  1823.  
  1824.     for (i = 0; i < nslots; i++)
  1825.     scavenge(instance->slots + i);
  1826.  
  1827.     return sizeof(struct instance) + sizeof(obj_t)*(nslots - 1);
  1828. }
  1829.  
  1830. static obj_t trans_instance(obj_t instance)
  1831. {
  1832.     obj_t class = INST(instance)->class;
  1833.     int nslots = DC(class)->instance_length;
  1834.  
  1835.     return transport(instance, sizeof(struct instance) + sizeof(obj_t)*(nslots-1));
  1836. }
  1837.  
  1838. void scavenge_instance_roots(void)
  1839. {
  1840.     scavenge(&obj_DefinedClassClass);
  1841.     scavenge(&obj_SlotDescrClass);
  1842.     scavenge(&obj_InitargDescrClass);
  1843.     scavenge(&obj_InheritedDescrClass);
  1844.     scavenge(&obj_PosTableClass);
  1845.     scavenge(&obj_InitializerClass);
  1846. }
  1847.  
  1848. /* Init stuff. */
  1849.  
  1850. void make_instance_classes(void)
  1851. {
  1852.     obj_DefinedClassClass
  1853.     = make_builtin_class(scav_defined_class, trans_defined_class);
  1854.     obj_SlotDescrClass = make_builtin_class(scav_slot_descr, trans_slot_descr);
  1855.     obj_InitargDescrClass =
  1856.       make_builtin_class(scav_initarg_descr, trans_initarg_descr);
  1857.     obj_InheritedDescrClass =
  1858.       make_builtin_class(scav_inherited_descr, trans_inherited_descr);
  1859.     obj_PosTableClass = make_builtin_class(scav_postable, trans_postable);
  1860.     obj_InitializerClass =
  1861.       make_builtin_class(scav_initializer, trans_initializer);
  1862. }
  1863.  
  1864. void init_instance_classes(void)
  1865. {
  1866.     init_builtin_class(obj_DefinedClassClass, "<defined-class>",
  1867.                obj_ClassClass, NULL);
  1868.     init_builtin_class(obj_SlotDescrClass, "<slot-descriptor>",
  1869.                obj_ObjectClass, NULL);
  1870.     init_builtin_class(obj_InitargDescrClass, "<initarg-descriptor>",
  1871.                obj_ObjectClass, NULL);
  1872.     init_builtin_class(obj_InheritedDescrClass, "<inherited-descriptor>",
  1873.                obj_ObjectClass, NULL);
  1874.     init_builtin_class(obj_PosTableClass, "<position-table>",
  1875.                obj_ObjectClass, NULL);
  1876.     init_builtin_class(obj_InitializerClass, "<initializer>",
  1877.                obj_ObjectClass, NULL);
  1878. }
  1879.  
  1880. void init_instance_functions(void)
  1881. {
  1882.     obj_t obj_FalseClass = object_class(obj_False);
  1883.  
  1884.     define_function("make-slot",
  1885.             listn(5, obj_ObjectClass, obj_FixnumClass,
  1886.               obj_FunctionClass,
  1887.               type_union(obj_FunctionClass, obj_FalseClass),
  1888.               type_union(obj_TypeClass, obj_FalseClass)),
  1889.             FALSE,
  1890.             listn(4, pair(symbol("init-keyword"), obj_False),
  1891.               pair(symbol("required-init-keyword"), obj_False),
  1892.               pair(symbol("init-function"), obj_Unbound),
  1893.               pair(symbol("init-value"), obj_Unbound)),
  1894.             FALSE, obj_SlotDescrClass, make_slot_descriptor);
  1895.     define_function("make-initarg",
  1896.             list2(obj_ObjectClass, obj_ObjectClass),
  1897.             FALSE,
  1898.             list3(pair(symbol("type"), obj_False),
  1899.               pair(symbol("init-function"), obj_Unbound),
  1900.               pair(symbol("init-value"), obj_Unbound)),
  1901.             FALSE, obj_InitargDescrClass, make_initarg_descr);
  1902.     define_function("make-inherited",
  1903.             list1(obj_ObjectClass),
  1904.             FALSE,
  1905.             list2(pair(symbol("init-function"), obj_Unbound),
  1906.               pair(symbol("init-value"), obj_Unbound)),
  1907.             FALSE, obj_InheritedDescrClass, make_inherited_descr);
  1908.     define_generic_function("make", 1, FALSE, obj_Nil, TRUE,
  1909.                 obj_Nil, obj_ObjectClass);
  1910.     define_method("make", list1(obj_ClassClass), TRUE, obj_Nil, FALSE,
  1911.           obj_ObjectClass, dylan_make);
  1912.     define_method("make", list1(obj_DefinedClassClass), TRUE, obj_Nil, FALSE,
  1913.           obj_ObjectClass, dylan_make_instance);
  1914.     define_generic_function("initialize", 1, FALSE, obj_Nil, TRUE,
  1915.                 obj_Nil, obj_ObjectClass);
  1916.     define_method("initialize", list1(obj_ObjectClass), TRUE, obj_Nil, FALSE,
  1917.           obj_ObjectClass, dylan_init);
  1918.     initialize_gf_variable =
  1919.       find_variable(module_BuiltinStuff, symbol("initialize"), FALSE, TRUE);
  1920.     define_method("slot-initialized?",
  1921.           list2(obj_ObjectClass, obj_FunctionClass),
  1922.           FALSE, obj_Nil, FALSE, obj_BooleanClass,
  1923.           dylan_slot_initialized_p);
  1924.  
  1925.     define_method("slot-descriptors", list1(obj_ClassClass), FALSE,
  1926.           obj_False, FALSE, obj_ObjectClass,
  1927.           dylan_class_slot_descriptors);
  1928.     define_method("slot-descriptors", list1(obj_DefinedClassClass), FALSE,
  1929.           obj_False, FALSE, obj_ObjectClass,
  1930.           dylan_dc_slot_descriptors);
  1931.     define_method("slot-name", list1(obj_SlotDescrClass), FALSE,
  1932.           obj_False, FALSE, obj_ObjectClass, dylan_slot_name);
  1933.     define_method("slot-allocation", list1(obj_SlotDescrClass), FALSE,
  1934.           obj_False, FALSE, obj_ObjectClass, dylan_slot_alloc);
  1935.     define_method("slot-getter", list1(obj_SlotDescrClass), FALSE,
  1936.           obj_False, FALSE, obj_ObjectClass, dylan_slot_getter);
  1937.     define_method("slot-getter-method", list1(obj_SlotDescrClass), FALSE,
  1938.           obj_False, FALSE, obj_ObjectClass, dylan_slot_getter_method);
  1939.     define_method("slot-setter", list1(obj_SlotDescrClass), FALSE,
  1940.           obj_False, FALSE, obj_ObjectClass, dylan_slot_setter);
  1941.     define_method("slot-setter-method", list1(obj_SlotDescrClass), FALSE,
  1942.           obj_False, FALSE, obj_ObjectClass, dylan_slot_setter_method);
  1943.     define_method("slot-type", list1(obj_SlotDescrClass), FALSE,
  1944.           obj_False, FALSE, obj_ObjectClass, dylan_slot_type);
  1945.     define_generic_function("slot-value", 2, FALSE, obj_False, FALSE,
  1946.                 list2(obj_ObjectClass, obj_BooleanClass),
  1947.                 obj_False);
  1948.     add_method(find_variable(module_BuiltinStuff, symbol("slot-value"),
  1949.                  FALSE, FALSE)->value,
  1950.            make_raw_method("slot-value",
  1951.                    list2(obj_SlotDescrClass, obj_ObjectClass),
  1952.                    FALSE, obj_False, FALSE,
  1953.                    list2(obj_ObjectClass, obj_BooleanClass),
  1954.                    obj_False, dylan_slot_value));
  1955.     define_method("slot-value-setter",
  1956.           list3(obj_ObjectClass, obj_SlotDescrClass,obj_ObjectClass),
  1957.           FALSE, obj_False, FALSE, obj_ObjectClass,
  1958.           dylan_slot_value_setter);
  1959. }
  1960.